{-# LANGUAGE OverloadedStrings,InstanceSigs,TupleSections    #-}
{-# LANGUAGE QuasiQuotes,MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell,TypeFamilies,FlexibleInstances #-}

module CMS.Handler.Account (
  postUserProfileR,
  getUserProfileR,
  getRegisterR,
  postRegisterR,
  getLoginR,
  postLoginR,
  getLogoutR,
  getCaptchaR,
  getUserChangePwdR,
  postUserChangePwdR
  ) where
import CMS.Data
import Yesod
import CMS.View.Account
import CMS.View.Common
import Data.Either
import Data.Maybe
import qualified App.UserCenter.Core as UC
import qualified App.Common.Helper as CH
import Control.Monad
import Data.Int
import qualified System.IO as SI
import qualified Data.Text as T
import App.UserCenter.DB
import qualified System.Directory as SD

getRegisterR::Handler Html
getRegisterR = indexLayout wReigister Nothing

postRegisterR::Handler Html
postRegisterR = do
  tuple <- runInputPost $ (,,) <$> iopt textField "account" 
                                         <*> iopt textField "pwd" 
                                         <*> iopt textField "vcode"
  let (acc,pwd,vcode) = CH.mapTuple3 (fromMaybe "") tuple
  isSucc <- UC.miniRegisterUser acc pwd vcode
  let (goUrl,tipStr) = either (RegisterR,) (const (HomeR,"注册成功")) isSucc
  jumpMessage tipStr goUrl Nothing

getLoginR::Handler Html
getLoginR = do
  isLogin <- UC.checkLogin
  when isLogin (redirect HomeR)
  indexLayout wLogin Nothing

postLoginR::Handler Html
postLoginR = do
  tuple <- runInputPost $ (,) <$> iopt textField "account"
                              <*> iopt textField "pwd"
  let (acc,pwd) = CH.mapTuple (fromMaybe "") tuple
  eitherInfo <- UC.loginUser acc pwd
  case eitherInfo of
    Left err -> jumpMessage err LoginR Nothing
    Right _  -> redirect HomeR

getCaptchaR::Handler Html
getCaptchaR = do
  (s,bytes)<- UC.setCaptchaSession
  sendResponse (typePng, toContent bytes)

getLogoutR::Handler Html
getLogoutR = do
  UC.logout
  redirect HomeR

getUserProfileR::Handler Html
getUserProfileR  = do
   login <- UC.getLoginUser
   case login of
     Nothing -> redirect HomeR
     Just r  -> indexLayout (wProfile r) login

postUserProfileR::Handler Html
postUserProfileR = do
  loginUser <- UC.getLoginUser
  when (isNothing loginUser) (redirect HomeR)
  let user = fromMaybe undefined loginUser
  (nick,em,qq,desc,mayImg) <- runInputPost $ (,,,,) <$> ireq textField "nickName"
                                <*> iopt textField "email"
                                <*> iopt textField "qq"
                                <*> ireq textField "shortDesc"
                                <*> iopt fileField "headImg"
  headImg <- case mayImg of
               Nothing  -> return Nothing
               Just img -> do
                 liftIO $ do
                  let movePath = "static/upfile/user/" <> (T.unpack $ userAccount user)
                  SD.createDirectoryIfMissing True movePath
                  fileMove img  $　movePath　<>　"/head.jpeg"
                  return $ Just $  "/" <> movePath　<>　"/head.jpeg"
  UC.updateUser nick em desc qq (T.pack <$> headImg)
  jumpMessage "修改成功" UserProfileR loginUser


getUserChangePwdR::Handler Html
getUserChangePwdR = do
  loginUser <- UC.getLoginUser
  case loginUser of
    Nothing -> redirect HomeR
    Just x  -> indexLayout (wChangePwd x) loginUser

postUserChangePwdR::Handler Html
postUserChangePwdR = do
  loginUser <- UC.getLoginUser
  when (isNothing loginUser) (redirect HomeR)
  tp <- runInputPost $ (,) <$> iopt textField "oldPwd"
                                        <*> iopt textField "newPwd"
  let user = fromMaybe undefined loginUser
  let (oldPwd,newPwd) = CH.mapTuple (fromMaybe "") tp
  ret <- UC.replacePwd (userAccount user) oldPwd newPwd
  case ret of
    Left  l -> jumpMessage l UserChangePwdR loginUser
    Right _ -> jumpMessage "修改成功" UserChangePwdR loginUser 

